COMMENT ⊗   VALID 00008 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	begin "texdoc" comment This is an experimental program that converts structured
C00020 00003	Lookup procedures
C00029 00004	Outline of the finite-state scanner for phase 1
C00037 00005	Preparations for the recursive-descent scanner in Phase 2
C00041 00006	Scanning procedures for phase 2
C00064 00007	Phase 1
C00076 00008	Phase 2
C00081 ENDMK
C⊗;
begin "texdoc" comment This is an experimental program that converts structured
"top-down" documentation into a suitable format for printing. The input is a
.DOC file having the form described at the beginning of UNDOC.SAI, while the
output will be in a corresponding .TEX file ready for typesetting.

The .TEX file output is arranged in numbered sections. A new section number
occurs for each blank line or end-of-page in the input .DOC file.

TEXDOC does its job in two phases. First it reads the entire source file into main
memory, collecting cross-reference information as it goes. This first phase is
similar to the UNDOC program, and in fact it has deliberately been written so that
the analogies are clear (at the expense of a little bit of efficiency). Then
TEXDOC spews out all the results, in a second phase that is similar to the
BLAISE program.
;
require "⊂⊃⊂⊃" delimiters; "used for macros"
define # = ⊂;comment⊃; "used henceforth instead of quoted comments like this"
define nextline = ⊂('15&'12)⊃ # carriage-return and line-feed in print commands;
define thru = ⊂step 1 until⊃ # abbreviation for for clauses;
define DEBUGONLY = ⊂comment⊃ # changed to ⊂⊃ when debugging;
define saf = ⊂safe⊃ # used when an array is believed to require no bounds checks;
DEBUGONLY redefine saf = ⊂⊃ # when debugging, belief turns to disbelief;
DEBUGONLY external procedure bail # the SAIL debugger in case of need;
require 25000 string_space;
require 400 system_pdl;
require 100 string_pdl;

label phase2 # go here when phase 1 is finished;
label finalend # go here when phase 2 is finished;

integer ichan,ochan,brchar,eof,lineno,pageno # standard variables of input system;
string filename,inputfile,outputfile # variables relating to file names;
string saf array fn[0:2] # components of file name;
procedure scanfilename # parses filename, puts parts in the fn array;
begin integer t # (0,1,2) for (name,ext,ppn);
string s # temporary storage;
integer c # current character of string;
s←filename; t←0; fn[0]←fn[1]←fn[2]←"";
while (c←lop(s)) do
	begin if c="." then t←1 else if c="[" then t←2;
	fn[t]←fn[t]&c;
	end;
end;

procedure initio # initialize input and output;
begin while true do
	begin print("Input file: "); filename←inchwl; scanfilename;
	if fn[1]=0 then fn[1]←".DOC";
	inputfile←fn[0]&fn[1]&fn[2];
	open(ichan←getchan,"DSK",0,19,0,100,brchar,eof);
	lookup(ichan,inputfile,eof);
	if not eof then done;
	print("Lookup failed on file ",inputfile,"!",nextline);
	release(ichan);
	end;
while true do
	begin fn[1]←".TEX";
	outputfile←fn[0]&fn[1]&fn[2];
	print("Output file (default = ",outputfile,"): ");
	filename←inchwl;
	if filename then
		begin scanfilename;
		outputfile←fn[0]&fn[1]&fn[2];
		end;
	open(ochan←getchan,"DSK",0,0,19,0,0,eof);
	enter(ochan,outputfile,eof);
	if not eof then done;
	print("Can't write on file ",outputfile,"!",nextline);
	release(ochan);
	filename←inputfile; scanfilename;
	end;
setprint("errors.tmp","B") # output goes to file as well as to user terminal;
setbreak(1,'14,null,"INA") # input(ichan,1) will read up to and including <FF>;
end;

integer cursec # current section number (beginning with 1);
string inbuf,curbuf # buffers while reading;

procedure error(string s) # prints a message to report an anomaly;
print(nextline,"p.",pageno,",l.",lineno,": ",s);
procedure error2(string s) # errors in phase 2;
begin integer n,m;
print(nextline,"! ",s,".",nextline,"(in section ",cursec,") ");
n←length(inbuf); m←length(curbuf); n←n-m;
if n≤50 then print(inbuf[1 to n]) else print("...",inbuf[n-50 to n]);
if m≤50 then print('12&curbuf) else print('12&curbuf[1 to 50]&"...");
end;

procedure overflow(string s) # prints error message and aborts phase 1;
begin error("Capacity exceeded ("); print(s,"), some input is lost.");
go to phase2;
end;
procedure overflow2(string s) # prints error message and dies;
begin print(nextline,"Capacity exceeded in phase 2 (",s,"), must quit.");
go to finalend;
end;

define memsize=10000 # size of mem;
integer saf array mem[0:memsize] # memory for instructions and cross-references;
define info(p)=⊂(mem[p] lsh -18)⊃ # left half of mem[p];
define link(p)=⊂(mem[p] land '777777)⊃ # right half of mem[p];
define stop=0,newsec=1,def0=2,def1=3,def2=4,def3=5,def4=6,
	txt=7,comt=8,ttl=9 # op-codes;
integer m # the current instruction, starts at 1 and increases;
integer mm # the previous cross ref, starts at memsize and decreases;
procedure compile(integer op,adr) # used to store the next "instruction";
begin if m≥mm then overflow("memsize");
mem[m]←(op lsh 18)+adr; m←m+1;
end;
procedure xref(integer no,lnk) # used to insert a cross reference;
begin if m≥mm then overflow("memsize");
mm←mm-1; mem[mm]←(no lsh 18)+lnk;
end;

define txtsize=10000 # number of text strings;
string saf array texts[0:txtsize] # nontitle texts;
integer txtptr # the number of stored texts;

integer curtitle # pointer to current title being defined in phase 2;
integer nn # section number of the title most previously processed by p_title;
integer tlineno # line number where current title began;
comment Lookup procedures;

comment Titles are stored in two conventional binary search trees, whose
nodes contain the following fields:
	str[k], the title stored at node k (a string) followed by "}",
	left[k], left son of node k,
	right[k], right son of node k,
	eq[k], the defined equivalent of node k.
	xr[k], pointer to the list of all section numbers where node k is used.
Constant and macro titles appear in a tree whose root is conroot, other titles
appear in a tree whose root is titlroot. The value eq[k] for constants is the
section number where that constant is defined, for undefined identifiers it is zero,
and for macros it is the negative of the section number. The value of eq[k] for
other titles is either 0 (undefined) or positive (the section number of
definition) or negative (the negative of a pointer to the list of cross-references
to all sections where this title has been defined). When str[k] is a reserved word,
xr[k] is the negative of the type code of that reserved word used in phase 2.
;
define strsize=1500 # number of different titles allowed;
string saf array str[0:strsize] # title names;
integer saf array left,right,eq,xr[0:strsize] # sons and equivalents;
integer nstrs # number of nodes in the tree;
integer titlroot,conroot # roots of trees;

integer procedure findabbr(string x) # looks for an abbreviated title;
begin comment If x is not the abbreviation of a unique title, an error
message is given and 0 is returned. Otherwise the index k such that x is a
prefix of str[k] is returned;
label ambig # go here if there's more than one match;
label errorprint # go here to complete the error message;
string xx # x with the closing "..." removed;
xx←x[1 to ∞-3];
if xx[∞ to ∞] = " " then xx←xx[1 to ∞-1];
if titlroot then
	begin integer k # current node;
	integer l # the length of xx;
	k←titlroot; l←length(xx);
	while true do
		begin string s,t; integer d;
		if equ(xx,str[k][1 to l]) then
			begin integer p;
			if (p←left[k]) then
				begin while right[p] do p←right[p];
				if equ(xx,str[p][1 to l]) then go to ambig;
				end;
			if (p←right[k]) then
				begin while left[p] do p←left[p];
				if equ(xx,str[p][1 to l]) then go to ambig;
				end;
			return(k);
			end;
		s←xx; t←str[k];
		while (d←lop(s)-lop(t))=0 do;
		if d<0 then k←left[k] else k←right[k];
		if k=0 then done;
		end;
	end;
error("Unmatched"); go to errorprint;
ambig: error("Ambiguous");
errorprint: print(" abbreviation: {",x,"}."); return(0);
end;

integer procedure find(string x; integer mode) # looks for the title name x;
begin comment If mode=0, this procedure finds x in the title tree, inserting
x if x wasn't already present. If mode=1, this procedure similarly finds x in
the constant tree. If mode=2, this procedure looks for x in the constant tree,
but doesn't insert it. The value returned is the node where x was found, or 0
if it wasn't;
integer k # current node;
integer lnk # pointer to new node if insertion needs to be done;
string xx # x with a right brace after it;
xx←x&"}";
case mode of begin
[0] begin if equ(x[∞-2 to ∞],"...") then return(findabbr(x));
	k←titlroot; lnk←nstrs+1 end;
[1] begin k←conroot; lnk←nstrs+1 end;
[2] begin k←conroot; lnk←0 end
  end;
if k=0 then
	if mode then conroot←lnk else titlroot←lnk
else while true do
	begin string s,t; integer d;
	if equ(xx,str[k]) then return(k);
	s←xx; t←str[k];
	while (d←lop(s)-lop(t))=0 do;
	comment No string will be a prefix of another since they end with "}";
	if d<0 then
		if left[k] then k←left[k]
		else	begin left[k]←lnk; done;
			end
	else	if right[k] then k←right[k]
		else	begin right[k]←lnk; done;
			end;
	end;
if lnk then
	begin if lnk≥strsize then overflow("strsize");
	str[nstrs←lnk]←xx; eq[nstrs]←left[nstrs]←right[nstrs]←xr[nstrs]←0;
	end;
return(lnk);
end;

integer procedure reverse(integer p) # reverses the reference list starting at p;
begin integer q,r;
q←0; while true do
	begin r←link(p);
	mem[p]←(mem[p] land '777777000000)+q;
	if r=0 then return(p);
	q←p; p←r;
	end;
end;

procedure outlist(integer p) # outputs a list of references;
begin if link(p) then
	begin comment more than one reference;
	out(ochan,"s ") # makes preceding word plural;
	out(ochan,cvs(info(p))); p←link(p);
	if link(p) then
		begin comment more than two references;
		integer n; n←20;
		while true do
			begin out(ochan,", ");
			if n=0 then
				begin out(ochan,nextline) # avoid long line;
				n←20;
				end
			else n←n-1;
			out(ochan,cvs(info(p))); p←link(p);
			if link(p)=0 then done;
			end;
		out(ochan,", ");
		end;
	out(ochan," and");
	end;
out(ochan," "); out(ochan,cvs(info(p))); out(ochan,".");
end;

recursive procedure outtree(integer p) # prints cross-references in subtree p;
if p then
	begin outtree(left[p]);
	if xr[p]>0 then
		begin integer q;
		integer n; n←20;
		out(ochan,"\\");
		out(ochan,str[p][1 to ∞-1]);
		out(ochan,":");
		if eq[p] then
			begin out(ochan,"\&{");
			out(ochan,cvs(abs(eq[p]))); out(ochan,"}, ");
			end;
		q←reverse(xr[p]); while true do
			begin out(ochan,cvs(info(q)));
			q←link(q);
			if q=0 then done;
			out(ochan,", ");
			if n=0 then
				begin out(ochan,nextline) # avoid long line;
				n←20;
				end
			end;
		out(ochan,"."&nextline);
		end;
	outtree(right[p]);
	end;
comment Outline of the finite-state scanner for phase 1;

comment Here are the different types of character codes distinguished:;
define space=0 # space or tab;
define lf=1 # line-feed;
define cr=2 # carriage-return;
define ff=3 # form-feed;
define letter=4 # A...Z or a...z or _;
define digit=5 # 0...9;
define apost=6 # ';
define plus=7 # +;
define minus=8 # -;
define colon=9 # :;
define equals=10 # =;
define lbrace=11 # {;
define rbrace=12 # };
define lpren=13 # (;
define rpren=14 # );
define hash=15 # #;
define other=16 # none of the above;
define charcodes=other+1 # the number of different character types recognized;
preload_with [8] other,
	other, space, lf, other, ff, cr, [2] other,
	[8] other,
	letter, [7] other,
	space, [2] other, hash, [3] other, apost,
	lpren, rpren, other, plus, other, minus, [2] other,
	[8] digit,
	[2] digit, colon, [2] other, equals, [2] other,
	other, [7] letter,
	[16] letter,
	[3] letter, [5] other,
	other, [7] letter,
	[16] letter,
	[3] letter, lbrace, [2] other, rbrace, other;
integer saf array chartype[0:'177];

comment The state of the scanner appears in variable "state" and also in
a few other variables;
integer state # the scanner state;
integer c # the current character;
string id # current identifier being scanned;
integer defplace # current constant;
integer op # pending operator on constant;
string accum # current value of constant;
integer bal # excess of {'s over }'s;
integer lastc # previous character (maintained only when scanning comments);
integer deftype # type of title definition;
integer curdef # location of instruction preceding the current definition,
	or -1 if no definition is in progress;
string radix # "'" or "" when scanning constants;
string val # current value of identifier or constant being scanned;

string texte # the current string being compressed from the input;

comment The scanner states have the following significance:
	normal, outside of titles when nothing special is active.
	normal1, like normal but immediately following a line-feed.
	title1, just after scanning the opening { of a title.
	title2, scanning during the middle of a title.
	title3, just after scanning the closing } of a title.
	skipspaces, scanning titles when spaces are ignored.
	skipcomment, scanning comment titles.
	skipcr, skipping spaces and carriage-returns at beginning of a definition.
	ident, scanning an identifier.
	const, beginning of a constant.
	const1, after a constant has begun.
During states ident, const, and const1, the value of op is 0 if there's no
operation pending, otherwise op is "+" or "-" and accum contains the value of
the current constant before the pending operation. Also defplace is 0 if the
current constant is not in a definition, otherwise it is the location of the
constant identifier being defined;

define normal=0, normal1=normal+charcodes, title1=normal1+charcodes,
title2=title1+charcodes, title3=title2+charcodes, skipspaces=title3+charcodes,
skipcomment=skipspaces+charcodes, skipcr=skipcomment+charcodes,
ident=skipcr+charcodes, const=ident+charcodes, const1=const+charcodes;

comment The following procedures do some of the most important operations
needed during the scanning process;

procedure storetext # call this when texte needs to be stored;
begin texts[txtptr]←texte; texte←"";
compile(txt,txtptr); 
if txtptr≥txtsize then overflow(txtsize);
txtptr←txtptr+1;
end;

procedure startdef # call this when a definition is beginning;
begin if curdef≥0 then
	begin error("Definition within a definition.");
	state←skipcr;
	end
else if deftype<2 then
	begin comment Non-constant definition;
	defplace←find(texte,0); state←skipcr; curdef←m;
	cursec←cursec+1;
	if defplace=0 or eq[defplace]=0 then eq[defplace]←cursec
	else	begin comment Appending to a definition; integer j; j←eq[defplace];
		if deftype=0 then error("Double definition of {"&str[defplace]&".");
		if j>0 then 
			begin xref(j,0); j←-mm;
			end;
		xref(cursec,-j); eq[defplace]←-mm;
		end;
	end
else	begin comment Constant or macro definition; defplace←find(texte,1);
	if eq[defplace] or xr[defplace] then
		error("Double definition of {"&str[defplace]&".");
	if deftype=2 then
		begin op←0; state←const; radix←""; eq[defplace]←cursec;
		end
	else	begin state←skipcr; curdef←m; eq[defplace]←-cursec;
		end;
	end;
texte←""; compile(def0+deftype,defplace);
end;

procedure finishdef # call this when a definition has ended;
begin if texte then storetext; curdef←-1;
end;

procedure processcon # call this when the character after a constant was scanned;
begin if op=0 then accum←val else if op="+" then accum←accum&"+"&val else
if op="-" then accum←accum&"-"&val;
if c="+" or c="-" then
	begin state←const; op←c;
	end
else if defplace>0 then
	begin texte←accum; state←skipcr;
	end
else	begin texte←texte&accum; state←normal;
	end;
end;

procedure finishid # used when leaving ident state;
begin if op then texte←texte&accum&op;
if defplace>0 then error("Undefined constant.");
state←normal;
end;
comment Preparations for the recursive-descent scanner in Phase 2;

define space2=1,letter2=2,digit2=3,doublequote2=4,singlequote2=5,lpren2=6,dot2=7,
lbr2=8,ident2=9,const2=10,otherchar2=11,star2=12,t_up=13,doubledots2=14,comma2=15,
colon2=16,t_comment=17,semi2=18,t_close=19,t_string=20,t_program=21,t_var=22,
t_procedure=23,t_begin=24,t_packed=25,t_to=26,t_div=27,t_nil=28,t_record=29,
t_array=30,t_of=31,t_case=32,t_repeat=33,t_until=34,t_then=35,t_if=36,
t_exit=37,t_end=38,underline2=39,t_else=40,t_eof=41,t_file=42,t_for=43,t_title=44,
hash2=45,t_def2=46,t_def3=47,t_def4=48,t_label=49
	# arbitrary codes used in the scanner;

preload_with t_eof, [7] otherchar2,
	otherchar2, [3] space2, t_eof, space2, [2] otherchar2,
	[8] otherchar2,
	underline2, [7] otherchar2,
	space2, otherchar2, doublequote2, hash2, [3] otherchar2, singlequote2,
	lpren2, t_close, star2, otherchar2, comma2, otherchar2, dot2, otherchar2,
	[8] digit2,
	[2] digit2, colon2, semi2, [4] otherchar2,
	t_up, [7] letter2,
	[16] letter2,
	[3] letter2, lbr2, otherchar2, t_close, t_up, otherchar2,
	singlequote2, [7] letter2,
	[16] letter2,
	[3] letter2, [5] otherchar2;
	saf integer array chartype2[0:'177] # types for SUAI ascii in phase 2;

string curstr # the current translated string;
define cr2='15, c5='14, c0='12, c2='13 # characters interpreted by the
	putout procedure;
integer state2 # if nonzero, this is substituted for the 0 or 2 in \0 or \2;
integer lastout # the last character that was putout (prevents consec cr's);
string putstr # parameter to putout;
procedure putout # sends putstr to output, slightly interpreting it;
begin integer c;
while true do
	begin c←lop(putstr);
	case c of begin
	[0] done;
	["\"] if putstr="6" then
		begin while true do
			begin out(ochan,c);
			if c="\" and putstr="7" then done;
			c←lop(putstr);
			end;
		end
	else if state2 and (putstr="0" or putstr="2") then
		begin out(ochan,"\"); out(ochan,state2); state2←0; c←lop(putstr);
		lastout←"\" # a little white lie;
		end
	else	begin out(ochan,"\"); lastout←"\";
		end;
	[cr2] if lastout≠cr2 then begin out(ochan,nextline); lastout←cr2 end;
	[c0] state2←"0";
	[c2] if state2≠"5" then state2←"2";
	[c5] state2←"5";
	else	begin out(ochan,c); lastout←c
		end
	  end;
	end;
end;
comment Scanning procedures for phase 2;

integer curtype # type of the token currently being scanned;
integer fillcount # increases by 1 when a new line or page is read;
boolean activity # getnext has been called;

string procedure p_title(integer n) # str[n] formatted as a title;
begin integer nl; string st;
nl←50; st←str[n][1 to ∞-1];
while length(st)>nl do
	begin comment try to avoid long lines in the output;
	integer c; string s; s←st[nl to ∞]; while true do
		begin c←lop(s); if c=0 or c='40 then done;
		end;
	if c=0 then nl←length(st) else
		begin integer k; k←length(st)-length(s); nl←nl+50; 
		st←st[1 to k-1]&nextline&s;
		end;
	end;
nn←eq[n]; if nn<0 then
	begin nn←-nn; while link(nn) do nn←link(nn); nn←info(nn);
	end
else if nn=0 then print(nextline,"Undefined title: {",str[n]);
return("\6"&st&"{ \:m"&cvs(nn)&"\7}");
end;

procedure getnext # gets the next input token;
begin comment The other phase2 procedures for scanning call this one whenever
the current character has been digested and it is time to read a new one.
This procedure is the lexical scanner. It processes identifiers, constants,
comments, "..", and ordinary single characters, setting curtype to the
appropriate code value. It also sets curstr equal to the translation of
the scanned token. Spaces in the input are ignored (except in strings and
comments);
integer c; label restart;
activity←true;
restart: if curbuf=0 then
	begin case info(m) of begin
	[stop][newsec][def0][def1] begin curtype←t_eof; return end;
	[def2][def3][def4] begin curtype←info(m)+(t_def2-def2); curstr←
	str[link(m)][1 to ∞-1]; m←m+1; return end;
	[txt] begin inbuf←curbuf←texts[link(m)]; m←m+1; go to restart end;
	[ttl] begin curtype←t_title; curstr←p_title(link(m));
	m←m+1; return end;
	[comt] begin curtype←t_comment; curstr←"$\{\;$"&texts[link(m)]&
	("$\;\}$"&cr2&c2); m←m+1; return end;
	else error2("Bug 3 in TEXDOC")
	  end;
	end;
c←lop(curbuf); curtype←chartype2[c];
case curtype of begin
[space2] go to restart;
[letter2] begin curstr←c; while true do
	begin c←chartype2[curbuf];
	if c=letter2 or c=digit2 or c=underline2 then curstr←curstr&lop(curbuf)
	else done;
	end;
c←find(curstr,1); if xr[c]<0 then curtype←-xr[c] else begin curtype←ident2;
curstr←"\\{"&curstr&"}" end end;
[digit2] begin curstr←c; curtype←const2; while true do
	begin c←chartype2[curbuf];
	if c=digit2 then curstr←curstr&lop(curbuf)
	else if c=letter2 then curstr←curstr&"\mathopen{\hbox{"&lop(curbuf)
		&"}}"
	else done;
	end end;
[doublequote2] begin curstr←"\hbox{\char'16}"; curtype←otherchar2 end # octal;
[hash2] begin curstr←"\.{\char'43}"; curtype←otherchar2 end # parameter mark;
[singlequote2] begin curstr←c; curtype←t_string; while true do
	begin c←lop(curbuf);
	if c='40 then curstr←curstr&"\ "
	else if c then
		begin curstr←curstr&c;
		if c="'" then done;
		end
	else	begin error2("String constant didn't end on the line"); done;
		end;
	end end;
[dot2] if curbuf="." then
	begin curtype←doubledots2; curstr←"\mathrel{\!.\,.\!}"; c←lop(curbuf);
	end
else curstr←c;
else curstr←c
  end;
end;

comment The recursive procedures below follow the syntax in BLAISE.SYN
fairly closely;
forward recursive string procedure p_fragment;
forward recursive string procedure p_genexp;
forward recursive string procedure p_outertoken;
forward recursive string procedure p_innertoken;
forward recursive string procedure p_token;
forward recursive string procedure p_speciallist;
forward recursive string procedure p_comments;
forward recursive string procedure p_variant;
forward recursive string procedure p_compoundstatement;
forward recursive string procedure p_statement1;
forward recursive string procedure p_noncompoundstatement;
forward recursive string procedure p_statement;
forward recursive string procedure p_case;

recursive string procedure p_fragment;
begin string str;
case curtype of begin
[t_program] begin str←"\3\2\&{"&curstr&"} "; getnext;
str←str&p_genexp&"\1" end;
[t_label] begin str←"\3\2\1\&{"&curstr&"} "; getnext;
while true do
	begin case curtype of begin
	[ident2][const2][t_title] begin str←str&"\0"&curstr; getnext end;
	[comma2] begin str←str&curstr&"\45\ "; getnext end;
	[t_comment] begin str←str&"\40\ "&curstr; getnext end;
	else done
	  end
	end end;
[t_var] begin str←"\3\2\1\&{"&curstr&"} "; getnext;
str←str&p_genexp end;
[t_procedure] begin str←"\3\2\1\1\&{"&curstr&"} "; getnext;
str←str&p_genexp end;
[t_begin] begin str←"\3\2"; str←str&p_compoundstatement end;
[t_def2] begin str←"\3\2\1\&{define} \\{"&curstr&"} $=$ ";
getnext; str←str&p_genexp end;
[t_def3][t_def4] begin str←"\3\2\1\&{define} \\{"&curstr; if curtype=t_def3 then
str←str&"}\.{(\char'43)} $≡$ " else str←str&"} $≡$ "; getnext;
if curtype=t_begin then str←str&"\2"&p_compoundstatement else str←str&p_genexp end;
else str←c2&p_noncompoundstatement
  end;
return(str);
end;

recursive string procedure p_genexp;
begin string str; integer n;
n←50; str←""; while true do
	begin case curtype of begin
	[lpren2][dot2][lbr2][ident2][const2][otherchar2][star2]
	[t_up][doubledots2][comma2]
	[colon2][t_comment][t_string][t_record][t_packed][t_to][t_div][t_nil]
	[t_array][t_file][t_title] str←str&p_outertoken;
	else done
	  end;
	if length(str)>n then
		begin comment try to avoid long lines in output;
		str←str&cr2; n←n+50;
		end;
	end;
if str then return("$"&str&"$") else return("");
end;

recursive string procedure p_outertoken;
begin string str;
case curtype of begin
[lpren2][lbr2][t_array][t_file] begin if curtype=t_array then
str←"\mathop{\&{"&curstr&" }}" else if curtype=t_file then
str←"\mathop{\&{"&curstr&"}\!}"
else str←curstr; getnext; while true do
	begin integer n; n←50;
	case curtype of begin
	[lpren2][dot2][lbr2][ident2][const2][otherchar2][star2]
	[t_up][doubledots2][comma2]
	[colon2][t_comment][semi2][t_string][t_var][t_procedure][t_record][t_packed]
	[t_to][t_div][t_nil][t_array][t_file][t_title] str←str&p_innertoken;
	else done
	  end;
	if length(str)>n then
		begin comment try to avoid long lines in output;
		str←str&cr2; n←n+50;
		end;
	end;
if curtype = t_close then
 	begin str←str&curstr; getnext;
	end
else if curtype=t_of then
	begin str←str&"\mathop{\&{\ "&curstr&" }\!}"; getnext;
	end
else error2("Missing a closing symbol") end;
[ident2][const2][otherchar2][star2][t_up][t_packed][t_to][t_div][t_nil]
[t_title] str←p_token;
[dot2] begin str←curstr; getnext; str←str&p_token end;
[doubledots2] begin str←curstr; getnext end;
[comma2] begin str←curstr&"\45"; getnext end;
[colon2] begin str←"\mathrel"&curstr; getnext end;
[t_record] begin str←"\null$\1\2\&{"&curstr&"} "; getnext;
str←str&c0&p_speciallist;
if curtype=t_end then
	begin str←str&c2&"\2\&{"&curstr&"}$\null\3"; getnext;
	end
else	begin error2("Missing end of record type"); str←str&"\3";
	end end;
[t_comment] begin str←"\null$\40\ "&curstr&("$\null"&cr2); getnext end;
[t_string] begin str←"\.{"&curstr&"}"; getnext end;
else error2("Bug 1 in TEXDOC")
  end;
return(str);
end;

recursive string procedure p_innertoken;
begin string str;
case curtype of begin
[lpren2][dot2][lbr2][ident2][const2][otherchar2][star2]
[t_up][doubledots2][comma2][colon2]
[t_comment][t_string][t_record][t_packed][t_to][t_div][t_nil]
[t_array][t_file][t_title] str←p_outertoken;
[semi2] begin str←curstr&"\42\,"; getnext end;
[t_var][t_procedure] begin str←"\mathop{\&{"&curstr&"}}"; getnext end;
else error2("Bug 2 in TEXDOC")
  end;
return(str);
end;

recursive string procedure p_token;
begin string str;
case curtype of begin
[ident2][const2][otherchar2] begin str←curstr; getnext end;
[t_title] begin str←"\null$"&curstr&"$\null "; getnext end;
[t_packed] begin str←"\mathop{\&{"&curstr&" }\!}"; getnext end;
[t_to] begin str←"\mathrel{\&{"&curstr&"}}"; getnext end;
[t_up] begin str←"{\up}"; getnext end;
[star2] begin str←"{\ast}"; getnext end;
[t_div] begin str←"\mathbin{\&{"&curstr&"}}"; getnext end;
[t_nil] begin str←"\&{"&curstr&"}"; getnext end;
else error2("Missing token")
  end;
return(str);
end;

recursive string procedure p_speciallist;
begin string str,str1,str2;
str←""; while true do
	begin str2←p_genexp;
	if str2 then str←str&"\2"&str2;
	if curtype≠semi2 then done;
	str←str&curstr; getnext;
	str←str&p_comments;
	end;
while curtype=t_case do
	begin str←str&"\2\1\&{"&curstr&"} "; getnext;
	str←str&p_genexp;
	if curtype=t_of then
		begin str←str&" \&{"&curstr&"}"; getnext;
		end
	else error2("Missing `of'");
	while true do
		begin str←str&p_variant;
		if curtype≠semi2 then done;
		str←str&curstr; getnext;
		end;
	str←str&"\3";
	end;
return(str);
end;

recursive string procedure p_comments;
begin string str;
if curtype≠t_comment then return(cr2);
str←("\40\"&cr2)&curstr; getnext;
while curtype=t_comment do
	begin str←str&"\2"&curstr; getnext;
	end;
return(str);
end;

recursive string procedure p_variant;
begin string str;
str←p_comments;
case curtype of begin
[ident2][const2] ;
[t_title] curstr←"\null$"&curstr&"$\null ";
[comma2] curstr←curstr&"\45";
else return(str)
  end;
str←str&(cr2&"\2\1$")&curstr; getnext;
while true do
	begin case curtype of begin
	[ident2][const2] ;
	[t_title] curstr←"\null$"&curstr&"$\null ";
	[comma2] curstr←curstr&"\45";
	[t_comment] curstr←"\null$\40\ "&curstr&"$\null ";
	[colon2] begin str←str&"\mathrel"&curstr; getnext; done end;
	else	begin error2("Improper token list in variant"); done;
		end
	  end;
	str←str&curstr; getnext;
	end;
str←str&"\null$"&p_comments;
if curtype=lpren2 then
	begin str←str&curstr&c0; getnext;
	end
else error2("Missing `(' in variant");
str←str&p_speciallist;
if curtype=t_close then
	begin str←str&curstr; getnext;
	end
else error2("Missing `)' in variant");
str←str&p_comments;
return(str&"\3");
end;

recursive string procedure p_compoundstatement;
begin string str,str1; label recover;
str←"\&{"&curstr&"} "; getnext;
str←str&p_statement1;
recover: while curtype=semi2 do
	begin str←str&curstr; getnext;
	str←str&p_comments&p_statement;
	end;
str←str&p_comments;
if curtype=t_end then
	begin str←str&(c2&"\2\&{")&curstr&("}"&c2); getnext;
	end
else	begin error2("Missing `;'");
	str1←p_statement; if str1 then
		begin str←str&str1; go to recover;
		end;
	error2("Missing `end'");
	str←str&(c2&"\2"&c2);
	end;
return(str);
end;

boolean procedure labelpresent # looks ahead to see if colon and no equals is next;
begin integer c,d; label restart, quit;
restart: while chartype2[curbuf]=space2 do c←lop(curbuf);
if curbuf=0 then
	begin if info(m)≠txt then go to quit;
	inbuf←curbuf←texts[link(m)]; m←m+1; go to restart;
	end;
if chartype2[curbuf]=colon2 then
	begin label restart;
	d←lop(curbuf);
	restart: while chartype2[curbuf]=space2 do c←lop(curbuf);
	if curbuf=0 then
		begin if info(m)≠txt then
			begin curbuf←d; go to quit;
			end;
		inbuf←curbuf←texts[link(m)]; m←m+1; go to restart;
		end;
	if curbuf≠"=" then return(true) else curbuf←d&curbuf;
	end;
quit: return(false);
end;

recursive string procedure p_statement1;
begin string str,str1;
case curtype of begin
[t_comment] begin str←"\40\ "&curstr; getnext; while curtype=t_comment do
	begin str←str&"\2"&curstr; getnext;
	end;
str←str&p_statement end;
[t_begin] str←"\1"&p_compoundstatement&"\3";
[ident2][const2][t_title] if labelpresent then begin str←"\2"&curstr&": "; getnext;
str←str&p_statement1 end
else str←c0&p_noncompoundstatement;
else str←c0&p_noncompoundstatement
  end;
return(str);
end;

recursive string procedure p_noncompoundstatement;
begin string str; integer tif;
case curtype of begin
[t_exit] begin str←"\2\&{"&curstr; getnext;
if curtype=t_if then
	begin str←str&" "&curstr&"} "; getnext;
	end
else	begin error2("Missing `if'"); str←str&"}";
	end;
str←str&p_genexp end;
[t_if][t_for] begin tif←curtype; str←"\2\1\&{"&curstr; getnext;
str←str&"} "&p_genexp;
if curtype=t_then then
	begin str←str&" \&{"&curstr&"}"; getnext;
	end
else	begin error2("Missing `then' or `do'"); str←str&" ";
	end;
str←str&p_comments&p_statement&("\3"&c2)&p_comments;
if tif=t_if and curtype=t_else then
	begin str←str&"\2\&{"&curstr; getnext;
	str←str&"} "&p_statement1&c2&p_comments;
	end end;
[t_repeat] begin str←"\2\1\&{"&curstr; getnext;
str←str&"} "&p_statement1;
while curtype=semi2 do
	begin str←str&curstr; getnext;
	str←str&p_comments&p_statement;
	end;
str←str&p_comments&c2&"\3\2\&{";
if curtype=t_until then
	begin str←str&curstr; getnext;
	end
else error2("Missing `until'");
str←str&"} "&p_genexp&c2 end;
[t_case] begin str←"\2\1\&{"&curstr; getnext;
str←str&"} "&p_genexp;
if curtype = t_of then
	begin str←str&" \&{"&curstr&"}"; getnext;
	end
else error2("Missing `of'");
str←str&p_case;
while curtype=semi2 do
	begin str←str&curstr; getnext;
	str←str&p_case;
	end;
str←str&p_comments;
if curtype=t_end then
	begin str←str&c2&"\2\&{"&curstr&("}\3"&c2); getnext;
	end
else	begin error2("Missing `end'"); str←str&("\3\2"&c2);
	end end;
else begin str←p_genexp; if str then str←"\0"&str end
  end;
return(str);
end;

recursive string procedure p_statement;
begin string str;
case curtype of begin
[t_begin] begin str←str&"\2"; str←str&p_compoundstatement end;
[ident2][const2][t_title] if labelpresent then begin str←"\2"&curstr&": ";
getnext; str←str&p_statement1 end
else str←str&p_noncompoundstatement;
else str←str&p_noncompoundstatement
  end;
return(str);
end;

recursive string procedure p_case;
begin string str;
str←p_comments;
case curtype of begin
[ident2][const2][t_title] begin str←str&c2&"\2\1"; while true do
	begin case curtype of begin
	[comma2] begin str←str&curstr&"\45\ "; getnext end;
	[t_comment] begin str←str&"\40\ "&curstr; getnext end;
	[colon2] begin str←str&curstr&" "; getnext; done end;
	[ident2][const2][t_title] begin str←str&curstr; getnext end;
	else return(str&"\3")
	  end;
	end;
str←str&p_statement1&"\3" end;
else comment do nothing;
  end;
return(str);
end;
comment Phase 1;

initio # initialize the input/output system;
nstrs←conroot←titlroot←0 # initialize the search trees;
xr[find("label",1)]←-t_label;
xr[find("else",1)]←-t_else;
xr[find("case",1)]←-t_case;
xr[find("array",1)]←-t_array;
xr[find("and",1)]←-t_div;
xr[find("begin",1)]←-t_begin;
xr[find("div",1)]←-t_div;
xr[find("const",1)]←-t_var;
xr[find("do",1)]←-t_then;
xr[find("downto",1)]←-t_to;
xr[find("function",1)]←-t_procedure;
xr[find("exit",1)]←-t_exit;
xr[find("end",1)]←-t_end;
xr[find("file",1)]←-t_file;
xr[find("for",1)]←-t_for;
xr[find("if",1)]←-t_if;
xr[find("goto",1)]←-t_packed;
xr[find("in",1)]←-t_to;
xr[find("initprocedure",1)]←-t_procedure;
xr[find("record",1)]←-t_record;
xr[find("of",1)]←-t_of;
xr[find("mod",1)]←-t_div;
xr[find("loop",1)]←-t_begin;
xr[find("nil",1)]←-t_nil;
xr[find("not",1)]←-t_packed;
xr[find("packed",1)]←-t_packed;
xr[find("or",1)]←-t_div;
xr[find("procedure",1)]←-t_procedure;
xr[find("program",1)]←-t_program;
xr[find("to",1)]←-t_to;
xr[find("segmented",1)]←-t_packed;
xr[find("repeat",1)]←-t_repeat;
xr[find("set",1)]←-t_file;
xr[find("then",1)]←-t_then;
xr[find("var",1)]←-t_var;
xr[find("type",1)]←-t_var;
xr[find("until",1)]←-t_until;
xr[find("while",1)]←-t_for;
xr[find("with",1)]←-t_for;

mem[0]←0; m←1; mm←memsize # initialize the memory pool;
txtptr←0 # initialize the list of stored texts;

inbuf←""; pageno←0; state←normal; texte←""; curdef←-1; brchar←'14;
cursec←0;
print("(",inputfile);

while true do
	begin label scan # go here to scan a character without reading a new one;
	if c='12 then lineno←lineno+1;
	comment The next lines read one character of input;
	while inbuf=0 do
		begin if brchar='14 then
			begin pageno←pageno+1; lineno←1; print(" ",pageno);
			end;
		inbuf←input(ichan,1);
		if eof and inbuf=0 then go to phase2;
		if pageno=1 and lineno=1 and equ(inbuf[1 to 9],"COMMENT ⊗") then
			begin comment Skip TVedit directory page;
			while brchar≠'14 and not eof do inbuf←input(ichan,1);
			if eof then go to phase2;
			inbuf←"";
			end;
		end;
	c←lop(inbuf);
scan:	case state+chartype[c] of begin
	[normal+lf] begin state←normal1; texte←texte&c end;
	[normal+lbrace] begin bal←1; state←title1 end;
	[normal+rbrace] begin error("Extra }."); texte←texte&c end;
	[normal+letter] begin id←c; state←ident; defplace←0; op←0 end;
	[normal+space][normal+cr][normal+ff][normal+digit][normal+apost]
	[normal+plus][normal+minus][normal+colon][normal+equals]
	[normal+hash][normal+lpren][normal+rpren][normal+other] texte←texte&c;
	[normal1+cr][normal1+ff] begin finishdef; state←skipcr end;
	[normal1+space][normal1+lf][normal1+letter][normal1+digit][normal1+apost]
	[normal1+plus][normal1+minus][normal1+colon][normal1+equals][normal1+lbrace]
	[normal1+rbrace][normal1+lpren][normal1+rpren][normal1+hash][normal1+other]
	begin state←normal; go to scan end;
	[title1+lbrace] begin integer op; op←comt;
	if texte then storetext else if curdef<0 then
	begin cursec←cursec+1; op←newsec end; compile(op,txtptr);
	state←skipcomment end;
	[title1+space][title1+lf][title1+cr][title1+ff][title1+letter]
	[title1+digit][title1+apost][title1+plus][title1+minus][title1+colon]
	[title1+equals][title1+rbrace][title1+lpren][title1+rpren][title1+hash]
	[title1+other] begin if texte then storetext;
	state←skipspaces; deftype←0; go to scan end;
	[skipspaces+ff][skipcomment+ff][title2+ff] begin state←normal;
	error("Runaway commment (not complete at end of page), see line ");
	print(tlineno,".") end;
	[skipcomment+lbrace] begin bal←bal+1; lastc←c; texte←texte&c end;
	[skipcomment+rbrace] begin bal←bal-1; if bal<0 then
	begin if lastc≠c then error("Comment didn't end with }}.") else texte←
	texte[1 to ∞-1]; while texte='40 do c←lop(texte); 
	while texte[∞ for 1]='40 do texte←texte[1 to ∞-1];
	storetext; m←m-1 # the command was already compiled;
	state←skipcr end else begin lastc←c; texte←texte&c end end;
	[skipcomment+space][skipcomment+cr][skipcomment+letter]
	[skipcomment+digit][skipcomment+apost][skipcomment+plus][skipcomment+minus]
	[skipcomment+colon][skipcomment+equals][skipcomment+lpren]
	[skipcomment+rpren][skipcomment+hash][skipcomment+other] begin lastc←c;
	texte←texte&c end;
	[skipspaces+letter][skipspaces+digit][skipspaces+apost][skipspaces+plus]
	[skipspaces+minus][skipspaces+equals][skipspaces+lbrace][skipspaces+rbrace]
	[skipspaces+colon][skipspaces+lpren][skipspaces+rpren][skipspaces+hash]
	[skipspaces+other] begin state←title2; go to scan end;
	[title2+space][title2+cr] begin texte←texte&" "; state←skipspaces end;
	[title2+lbrace] begin texte←texte&c; bal←bal+1 end;
	[title2+rbrace] begin bal←bal-1; if bal=0 then begin state←title3;
	if texte[∞ to ∞]=" " then texte←texte[1 to ∞-1] # remove final space;
	end else texte←texte&c end;
	[title2+lf][title2+letter][title2+digit][title2+apost][title2+plus]
	[title2+minus][title2+colon][title2+equals][title2+lpren][title2+rpren]
	[title2+hash][title2+other] texte←texte&c;
	[title3+plus] deftype←1;
	[title3+colon] deftype←2;
	[title3+hash] deftype←3;
	[title3+minus] deftype←4;
	[title3+equals] startdef # Title definition found;
	[title3+lf][title3+cr][title3+ff][title3+letter][title3+digit]
	[title3+apost][title3+lbrace][title3+rbrace][title3+lpren]
	[title3+rpren][title3+other] begin comment Title use found; integer j;
	compile(ttl,j←find(texte,0)); texte←case deftype of ("","+",":","#","-");
	if info(xr[j])≠cursec then begin xref(cursec,xr[j]); xr[j]←mm end;
	state←normal; go to scan end;
	[const+letter] begin id←c; state←ident end;
	[const+apost] radix←"""" # double-quote is transmitted to phase2;
	[const+digit] begin val←radix&c; state←const1 end;
	[const+ff][const+plus][const+minus][const+colon][const+equals]
	[const+lbrace][const+rbrace][const+lpren][const+rpren][const+hash]
	[const+other] begin if defplace then
	error("Improper constant.") else texte←texte&accum&op;
	state←normal; go to scan end;
	[const1+digit] val←val&c;
	[const1+space][const1+lf][const1+cr][const1+ff][const1+letter]
	[const1+apost][const1+plus][const1+minus][const1+colon][const1+equals]
	[const1+lbrace][const1+rbrace][const1+lpren][const1+rpren][const1+hash]
	[const1+other] begin processcon;
	if state≠const then go to scan end;
	[ident+letter][ident+digit] id←id&c;
	[ident+space][ident+lf][ident+cr][ident+ff][ident+apost][ident+plus]
	[ident+minus][ident+colon][ident+equals][ident+lbrace][ident+rbrace]
	[ident+lpren][ident+rpren][ident+hash][ident+other] begin integer k;
	k←find(id,1); if xr[k]≥0 and info(xr[k])≠cursec then begin
	xref(cursec,xr[k]); xr[k]←mm end;
	if eq[k]<0 then
		begin comment macro call;
		finishid;
		texte←texte&id;
		go to scan;
		end
	else if eq[k]>0 then
		begin val←id; processcon; if state≠const then go to scan
		end
	else begin finishid; texte←texte&id; go to scan end end;
	[skipcr+lf] state←normal1;
	[skipcr+letter][skipcr+digit][skipcr+apost][skipcr+plus]
	[skipcr+minus][skipcr+colon][skipcr+equals][skipcr+lbrace][skipcr+rbrace]
	[skipcr+lpren][skipcr+rpren][skipcr+hash][skipcr+other]
	begin state←normal; go to scan end;
	else comment do nothing;
	  end;
	end;
comment Phase 2;

phase2: print(")"); release(ichan);
if texte then storetext;
if state=normal1 then finishdef
else if state≠normal then print(nextline,"Input ended unexpectedly.");
mem[m]←stop lsh 18 # This instruction will cause phase 2 to end;
m←1; cursec←0; out(ochan,"\input dochdr");
while true do
	begin curtitle←0;
	if cursec mod 10 = 0 then
		begin if cursec then
			begin print(" ",cursec div 10); out(ochan,""&'14);
			end
		else print(nextline&"[",outputfile);
		end;
	cursec←cursec+1;
	case info(m) of begin
	[stop] begin print(" ",(cursec+9)div 10,"]"); done end;
	[newsec] begin out(ochan,nextline&nextline&"\secbegin "); 
	out(ochan,texts[link(m)]); m←m+1 end;
	[def0][def1] begin out(ochan,nextline&nextline&"\secbegin ");
	curtitle←link(m); out(ochan,p_title(curtitle));
	if nn≠cursec then curtitle←0;
	if info(m)=def0 then out(ochan," \.=\par") else out(ochan," \.{+=}\par");
	m←m+1 end;
	else print(nextline,".DOC file should begin with a comment")
	  end;
	lastout←cr2; inbuf←curbuf←null;
	getnext;
	if curtype≠t_eof then
		begin out(ochan,nextline&"\pascal"&nextline);
		case curtype of begin
		[t_program][t_var][t_procedure][t_label][t_begin][t_def2][t_def3]
		[t_def4]
		out(ochan,"\1") # one extra unit of indent applying to the code;
		else comment do nothing;
		  end;
		while curtype≠t_eof do
			begin activity←false;
			while true do
				begin case curtype of begin
				[dot2][semi2] ;
				[t_comment] curstr←"\40\ "&curstr;
				else done
				  end;
				putstr←curstr; putout; getnext;
				end;
			putstr←cr2&p_fragment; putout; 
			if not activity then
				begin error2("Uninterpretable fragment"); getnext;
				end;
			end;
		end;
	if curtitle then
		begin comment Completion of a title definition;
		if eq[curtitle]<0 then
			begin integer p;
			out(ochan,nextline&nextline&"\note See also section");
			p←reverse(-eq[curtitle]);
			outlist(link(p));
			p←reverse(p);
			end;
		if xr[curtitle] then
			begin out(ochan,nextline&nextline&
				"\note This code is used in section");
			outlist(reverse(xr[curtitle]));
			end
		else print(nextline,"Unused title: {",str[curtitle]);
		end;
	end;
out(ochan,nextline&nextline&"\index"&nextline);
outtree(conroot);
out(ochan,"\endindex"&nextline);

finalend: release(ochan);
end